home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / specials.c < prev    next >
C/C++ Source or Header  |  1992-10-06  |  24KB  |  1,002 lines
  1. /* ******************************************************************** */
  2. /* specials.c        Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Language special forms (NOT toplevel forms)                          */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: specials.c,v 1.10 1992/03/07 21:45:16 pab Exp $
  9.  *
  10.  * $Log: specials.c,v $
  11.  * Revision 1.10  1992/03/07  21:45:16  pab
  12.  * initial continuation changes
  13.  *
  14.  * Revision 1.9  1992/02/10  16:41:09  pab
  15.  * fixed dynamics properly
  16.  *
  17.  * Revision 1.8  1992/01/29  13:47:28  pab
  18.  * bindig fix, gc fix in dynamic let
  19.  *
  20.  * Revision 1.7  1992/01/09  22:29:05  pab
  21.  * Fixed for low tag ints
  22.  *
  23.  * Revision 1.6  1992/01/07  22:13:27  pab
  24.  * *** empty log message ***
  25.  *
  26.  * Revision 1.5  1992/01/05  22:48:20  pab
  27.  * Minor bug fixes, plus BSD version
  28.  *
  29.  * Revision 1.4  1991/12/22  15:14:34  pab
  30.  * Xmas revision
  31.  *
  32.  * Revision 1.3  1991/09/22  19:14:40  pab
  33.  * Fixed obvious bugs
  34.  *
  35.  * Revision 1.2  1991/09/11  12:07:40  pab
  36.  * 11/9/91 First Alpha release of modified system
  37.  *
  38.  * Revision 1.1  1991/08/12  16:50:00  pab
  39.  * Initial revision
  40.  *
  41.  * Revision 1.4  1991/02/13  18:28:55  kjp
  42.  * Pass.
  43.  *
  44.  */
  45.  
  46. /*
  47.  * Change Log:
  48.  *   Version 1, March 1990 (Compiler rationalisation)
  49.  *     New fully working let/cc and unwind-protect - 
  50.  *       all stacks dealt with and dead continuations killed (KJP)
  51.  */
  52.  
  53. #include "funcalls.h"
  54. #include "defs.h"
  55. #include "structs.h"
  56. #include "error.h"
  57. #include "global.h"
  58.  
  59. #include "funcalls.h"
  60.  
  61. #include "slots.h"
  62. #include "garbage.h"
  63.  
  64. #include "symboot.h"
  65. #include "modules.h"
  66. #include "toplevel.h"
  67. #include "root.h"
  68. #include "allocate.h"
  69. #include "specials.h"
  70. #include "toplevel.h"
  71. #include "state.h"
  72.  
  73. /*
  74.  
  75.  * We're talking just the non-toplevel restricted special forms here
  76.  * like lambda, setq, and if - the ones always available.
  77.  
  78.  */
  79.  
  80. LispObject special_table;
  81.  
  82. LispObject my_make_special(LispObject *stacktop,
  83.                char *name, LispObject (*func)())
  84. {
  85.   LispObject ans,tmp;
  86.  
  87.   ans = (LispObject) get_symbol(stacktop,name);
  88.   STACK_TMP(ans);
  89.   tmp = (LispObject) allocate_special(stacktop,ans,func);
  90.   UNSTACK_TMP(ans);
  91.   ans->SYMBOL.lvalue=tmp;
  92.   STACK_TMP(ans);
  93.   EUCALL_3(tref_updator,special_table,ans,ans->SYMBOL.lvalue);
  94.   UNSTACK_TMP(ans);
  95.   return(ans->SYMBOL.lvalue);
  96. }
  97.  
  98. EUFUN_1( Fn_special_form_p, name)
  99. {
  100.   return(EUCALL_2(Fn_tref,special_table,name));
  101. }
  102. EUFUN_CLOSE
  103.  
  104. LispObject special_lambda;
  105. EUFUN_3( Sf_lambda, mod, env, forms)
  106. {
  107.   LispObject bvl,myforms;
  108.   LispObject ans,walker;
  109.   int i;
  110.  
  111.   if (forms == nil) {
  112.     CallError(stacktop,"lambda: illegal empty lambda form",nil,NONCONTINUABLE);
  113.   }
  114.  
  115.   myforms = forms;
  116.  
  117.   bvl = CAR(myforms); myforms = CDR(myforms);
  118.   STACK_TMP(bvl); STACK_TMP(myforms);
  119.  
  120.   walker = bvl; i = 0;
  121.   while (is_cons(walker)) {
  122.     walker = CDR(walker);
  123.     ++i;
  124.   }
  125.  
  126.   if (walker != nil)  /* improper lambda list */
  127.     ans = (LispObject) allocate_i_function(stacktop,mod,env,-i -1);
  128.   else
  129.     ans = (LispObject) allocate_i_function(stacktop,mod,env,i);
  130.  
  131.   UNSTACK_TMP(myforms); UNSTACK_TMP(bvl);
  132.   ans->I_FUNCTION.bvl  = bvl;
  133.   ans->I_FUNCTION.body = myforms;
  134.   ans->I_FUNCTION.home = ARG_0(stackbase);
  135.  
  136.   return ans;
  137. }
  138. EUFUN_CLOSE
  139.  
  140. LispObject special_macro_lambda;
  141. EUFUN_3(Sf_mlambda, mod, env, forms)
  142. {
  143.   LispObject bvl;
  144.   LispObject ans,walker;
  145.   int i;
  146.  
  147.   if (forms == nil) {
  148.     CallError(stacktop,
  149.           "macro-lambda: illegal empty macro-lambda form",nil,NONCONTINUABLE);
  150.   }
  151.  
  152.   bvl = CAR(forms); forms = CDR(forms);
  153.   ARG_2(stackbase)=forms;
  154.   walker = bvl; i = 0;
  155.   while (is_cons(walker)) {
  156.     walker = CDR(walker);
  157.     ++i;
  158.   }
  159.   STACK_TMP(bvl);
  160.   if (walker != nil)  /* improper lambda list */
  161.     ans = (LispObject) allocate_i_function(stacktop,mod,env,-i -1);
  162.   else
  163.     ans = (LispObject) allocate_i_function(stacktop,mod,env,i);
  164.  
  165.   UNSTACK_TMP(bvl);
  166.   lval_typeof(ans) = TYPE_I_MACRO;
  167.   ans->I_MACRO.bvl  = bvl;
  168.   ans->I_MACRO.body = ARG_2(stackbase)/*forms*/;
  169.   ans->I_MACRO.home = ARG_0(stackbase)/*mod*/;
  170.  
  171.   return ans;
  172. }
  173. EUFUN_CLOSE
  174.  
  175. LispObject special_setq;
  176. EUFUN_3( Sf_setq,  mod, env, forms)
  177. {
  178.   LispObject id;
  179.  
  180.   if (forms == nil) 
  181.     CallError(stacktop,"setq: illegal empty setq form",nil,NONCONTINUABLE);
  182.  
  183.   id = CAR(forms); forms = CDR(forms);
  184.  
  185.   if (!is_symbol(id))
  186.     CallError(stacktop,"setq: non-symbolic id",id,NONCONTINUABLE);
  187.  
  188.   if (CDR(forms)!=nil) 
  189.     CallError(stacktop,"setq: additional setq forms",nil,NONCONTINUABLE);
  190.  
  191.   while (reserved_symbol_p(id)) {
  192.     id = CallError(stacktop,"setq: reserved symbol",id,CONTINUABLE);
  193.   }
  194.   STACK_TMP(id);
  195.   forms = EUCALL_3(module_eval,mod,env,CAR(forms));
  196.   UNSTACK_TMP(id);
  197.   STACK_TMP(forms);
  198.   STACK_TMP(id);
  199.   env=ARG_1(stackbase);
  200.   while (env != NULL) {
  201.     if (env->ENV.variable == id) {
  202.       if (env->ENV.mutable) return (env->ENV.value = forms);
  203.       if (EUCALL_2(Fn_equal, forms, env->ENV.value)==nil) {
  204.     CallError(stacktop,"setq: immutable binding",id,NONCONTINUABLE);
  205.       }
  206.       return forms;
  207.     }
  208.     env = (LispObject) env->ENV.next;
  209.   }
  210.   UNSTACK_TMP(id);
  211.   UNSTACK_TMP(forms);
  212.   /* Going for the module environment */
  213.   mod=ARG_0(stackbase);
  214.   STACK_TMP(forms);
  215.   (void) EUCALL_3(module_set,mod,id,forms); /* In the module handler */
  216.   
  217.   return(forms);
  218.  
  219. }
  220. EUFUN_CLOSE
  221.  
  222. LispObject special_progn;
  223. EUFUN_3( Sf_progn, mod, env, forms)
  224. {
  225.   LispObject ret;
  226.  
  227.   if (!is_cons(forms))
  228.     CallError(stacktop,"progn: bad forms",forms,NONCONTINUABLE);
  229.  
  230.   ret = nil; /* Null case return value */
  231.  
  232.   while (is_cons(forms)) {
  233.     STACK_TMP(CDR(forms));
  234.     ret = EUCALL_3(module_eval,ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,CAR(forms));
  235.     UNSTACK_TMP(forms);
  236.   }
  237.  
  238.   return(ret);
  239. }
  240. EUFUN_CLOSE
  241.  
  242. LispObject special_if;
  243. EUFUN_3( Sf_if, mod, env, forms)
  244. {
  245.   LispObject pred,alt1,alt2;
  246.   LispObject debug;
  247.  
  248.   debug = forms;
  249.  
  250.   if (!is_cons(forms))
  251.     CallError(stacktop,"if: missing predicate",forms,NONCONTINUABLE);
  252.  
  253.   pred = CAR(forms); forms = CDR(forms);
  254.  
  255.   if (!is_cons(forms))
  256.     CallError(stacktop,"if: missing consequence",debug,NONCONTINUABLE);
  257.  
  258.   alt1 = CAR(forms); forms = CDR(forms);
  259.  
  260.   if (!is_cons(forms))
  261.     CallError(stacktop,"if: missing alternative",debug,NONCONTINUABLE);
  262.  
  263.   alt2 = CAR(forms); forms = CDR(forms);
  264.  
  265.   if (forms != nil)
  266.     CallError(stacktop,"if: extraneous forms",forms,NONCONTINUABLE);
  267.   
  268.   STACK_TMP(alt1);
  269.   STACK_TMP(alt2);
  270.   if (EUCALL_3(module_eval,mod,env,pred) != nil) {
  271.     UNSTACK_TMP(alt1); UNSTACK_TMP(alt1);
  272.     return(EUCALL_3(module_eval,ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,alt1));
  273.   }
  274.   else {
  275.     UNSTACK_TMP(alt2);
  276.     return(EUCALL_3(module_eval,ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,alt2));
  277.   }
  278. }
  279. EUFUN_CLOSE
  280.  
  281. /*
  282.  
  283.  * The continuation hacking special forms
  284.  
  285.  */
  286.  
  287. LispObject returned_continue_value;
  288. LispObject last_continue;
  289. LispObject target_continue; /* Used when unwinding... */
  290.  
  291. #define LETCC_DBG(x) /* x;fflush(stdout) */
  292.  
  293. LispObject special_letcc;
  294. EUFUN_3( Sf_letcc, mod, env, forms)
  295. {
  296.   LispObject id;
  297.   LispObject cont;
  298.   LispObject retval;
  299.   
  300.   if (!is_cons(forms))
  301.     CallError(stacktop,"let/cc: weird argument",forms,NONCONTINUABLE);
  302.  
  303.   if (!is_symbol(CAR(forms)))
  304.     CallError(stacktop,"let/cc: non-symbolic continuation name",id,NONCONTINUABLE);
  305.  
  306.   /* OK, now do the business... */
  307.   
  308.   cont = allocate_continue(stacktop);
  309.   STACK_TMP(cont);
  310.  
  311.   if (set_continue(stacktop,cont)) {
  312.  
  313.     /* We were resumed, return the value bit... */
  314.     UNSTACK_TMP(cont);
  315.     return(cont->CONTINUE.value);
  316.  
  317.   }
  318.   UNSTACK_TMP(cont);
  319.   /* The hard bit's done - just add value to env... */
  320.   STACK_TMP(cont);
  321.   
  322.   forms=ARG_2(stackbase);
  323.   id = CAR(forms); forms = CDR(forms);
  324.   
  325.   STACK_TMP(forms);
  326.   env = allocate_envimut(stacktop,id,cont,ARG_1(stackbase));
  327.   UNSTACK_TMP(forms);
  328.   /* retval... */
  329.   
  330.   retval = EUCALL_3(Sf_progn,ARG_0(stackbase)/*mod*/,env,forms);
  331.  
  332.   /* Normal return - kill continuation... */
  333.  
  334.   UNSTACK_TMP(cont);
  335.   unset_continue(cont);
  336.   return(retval);
  337.  
  338. }
  339. EUFUN_CLOSE
  340.   
  341. void call_continuation(LispObject *stacktop,LispObject cont,LispObject value)
  342. {
  343.   LispObject last;
  344.  
  345.   LETCC_DBG(fprintf(stderr,"call cont: continuation invoked\n"));
  346.  
  347.   /* First, check the continuation's still live... */
  348.  
  349.   if (!cont->CONTINUE.live)
  350.     CallError(stacktop,"continuation call: dead continuation",cont,NONCONTINUABLE);
  351.  
  352.   if (cont->CONTINUE.thread != CURRENT_THREAD())
  353.     CallError(stacktop,
  354.           "continuation call: not on this thread",cont,NONCONTINUABLE);
  355.  
  356.   /* That's cool, now wander down (up?) the dynamic continuation list
  357.              killing stuff off and looking for unwind protects        */
  358.  
  359.   last = SYSTEM_THREAD_SPECIFIC_VALUE(state_last_continue);
  360.  
  361.   while (last != cont) {
  362.  
  363.     if (last == nil) {
  364.       fprintf(stderr,"AARRRRGGHHH!!!: continuation vanished!");
  365.       exit(1);
  366.     }
  367.  
  368.     if (last->CONTINUE.unwind) {
  369.       LispObject temp;
  370.  
  371.       /* We have an unwind continuation */
  372.  
  373.       /* Leave interesting info for unwind-protect */
  374.  
  375.       last->CONTINUE.target = cont;
  376.       last->CONTINUE.value = value;
  377.  
  378.       /* Kill this unwind continuation */
  379.  
  380.       temp = last;
  381.       last 
  382.     = SYSTEM_THREAD_SPECIFIC_VALUE(state_last_continue) 
  383.       = temp->CONTINUE.last_continue;
  384.  
  385.       /* Jump... */
  386.  
  387.       call_continue(stacktop,temp,value);
  388.  
  389.     }
  390.  
  391.     /* Normal continuation - kill it ! */
  392.  
  393. LETCC_DBG(fprintf(stderr,"call cont: killing middle continue\n"));
  394.  
  395.     {
  396.       LispObject temp;
  397.  
  398.       temp = last->CONTINUE.last_continue;
  399.       last->CONTINUE.live = FALSE;
  400.       last->CONTINUE.last_continue = nil;
  401.       last = SYSTEM_THREAD_SPECIFIC_VALUE(state_last_continue) = temp;
  402.  
  403.     }
  404.  
  405.   }
  406.  
  407. LETCC_DBG(fprintf(stderr,"call cont: hacking world\n"));
  408.  
  409.   /* We've hit our own, so all is hunkydory */
  410.  
  411.   /* Jump away... */
  412.  
  413.   call_continue(stacktop,cont,value);
  414.  
  415. } 
  416.  
  417. LispObject special_unwind_protect; 
  418. EUFUN_3( Sf_unwind_protect, mod, env, forms)
  419. {
  420.   LispObject protected_form;
  421.   LispObject cont,value;
  422.  
  423.   if (!is_cons(forms))
  424.     CallError(stacktop,"unwind-protect: invalid null argument",nil,NONCONTINUABLE);
  425.  
  426.   protected_form = CAR(forms);
  427.  
  428.   /* OK, want to set up an unwind marker */
  429.  
  430.   cont = allocate_continue(stacktop); /* Allocate and freeze */
  431.   STACK_TMP(cont);
  432.   if (set_continue(stacktop,cont)) {
  433.     
  434.     /* We've been invoked - run the tidy up forms... */
  435.  
  436.     (void) EUCALL_3(Sf_progn,ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,
  437.             CDR(ARG_2(stackbase))/* unwind_forms*/);
  438.  
  439.     /* Got through that succesfully, so now try and find the target... */
  440.     UNSTACK_TMP(cont);
  441.     call_continuation(stacktop,cont->CONTINUE.target,cont->CONTINUE.value);
  442.  
  443.   }
  444.  
  445.   /* Mark the continuation as an unwind protect thing */
  446.   cont->CONTINUE.unwind = TRUE;
  447.   
  448.   value = EUCALL_3(module_eval,ARG_0(stackbase),ARG_1(stackbase),CAR(ARG_2(stackbase)));
  449.   
  450.   /* Kill off the continuation */
  451.   UNSTACK_TMP(cont);
  452.  
  453.   unset_continue(cont);
  454.  
  455.   /* Process the outward forms */
  456.  
  457.   STACK_TMP(value);
  458.   (void) EUCALL_3(Sf_progn,ARG_0(stackbase),ARG_1(stackbase),CDR(ARG_2(stackbase)));
  459.   UNSTACK_TMP(value);
  460.   return(value);
  461.  
  462. }
  463. EUFUN_CLOSE
  464. /*
  465.  
  466.  * Dynamics...
  467.  
  468.  */
  469.  
  470. LispObject special_dynamic_setq;
  471. EUFUN_3( Sf_dynamic_setq, mod, env, forms)
  472. {
  473.   LispObject id,form;
  474.   Env walker;
  475.  
  476.   if (!is_cons(forms))
  477.     CallError(stacktop,"dynamic-setq: missing symbol",forms,NONCONTINUABLE);
  478.  
  479.   id = CAR(forms); forms = CDR(forms);
  480.  
  481.   if (!is_symbol(id))
  482.     CallError(stacktop,"dynamic-setq: non-symbolic reference",id,NONCONTINUABLE);
  483.  
  484.   if (!is_cons(forms)) 
  485.     CallError(stacktop,"dynamic-setq: missing value form",forms,NONCONTINUABLE);
  486.  
  487.   form = CAR(forms); forms = CDR(forms);
  488.  
  489.   if (forms != nil)
  490.     CallError(stacktop,"dynamic-setq: extraneous forms",forms,NONCONTINUABLE);
  491.  
  492.   walker = DYNAMIC_ENV();
  493.  
  494.   while (walker != NULL) {
  495.     if (walker->variable == id)
  496.       {
  497.     STACK_TMP(walker);
  498.     form = EUCALL_3(module_eval,mod,env,form);
  499.     UNSTACK_TMP(walker);
  500.     return((walker->value = form));
  501.       }
  502.     walker = walker->next;
  503.   }
  504.  
  505.   if (id->SYMBOL.gvalue == NULL) {
  506.     fprintf(stderr,"****Illegal assignment to undeclared variable: ");
  507.     EUCALL_2(Fn_print,id,StdErr);
  508.     fprintf(stderr,"****Implicit defvar used\n");
  509.   }
  510.   STACK_TMP(id);
  511.   form = EUCALL_3(module_eval,mod,env,form);
  512.   UNSTACK_TMP(id);
  513.   return((id->SYMBOL.gvalue = form));
  514. }
  515. EUFUN_CLOSE
  516.  
  517. EUFUN_2( Fn_dynamic_setq, id, form)
  518. {
  519.   Env walker;
  520.  
  521.   if (!is_symbol(id))
  522.     CallError(stacktop,"(setter symbol-dynamic-value): non-symbolic reference",id,NONCONTINUABLE);
  523.  
  524.   walker = DYNAMIC_ENV();
  525.  
  526.   while (walker != NULL) {
  527.     if (walker->variable == id) return((walker->value = form));
  528.     walker = walker->next;
  529.   }
  530.  
  531.   if (id->SYMBOL.gvalue == NULL) {
  532.     fprintf(stderr,"****Illegal assignment to undeclared variable: ");
  533.     EUCALL_2(Fn_print,id,StdErr);
  534.     fprintf(stderr,"****Implicit defvar used\n");
  535.   }
  536.  
  537.   return((id->SYMBOL.gvalue = form));
  538. }
  539. EUFUN_CLOSE
  540.  
  541. LispObject special_dynamic_set;
  542. EUFUN_3( Sf_dynamic_set, mod, env, forms)
  543. {
  544.   LispObject id,form;
  545.   Env walker;
  546.  
  547.   if (!is_cons(forms))
  548.     CallError(stacktop,"dynamic-set: missing symbol",forms,NONCONTINUABLE);
  549.  
  550.   id = CAR(forms); forms = CDR(forms);
  551.  
  552.   id = EUCALL_3(module_eval,mod,env,id);
  553.  
  554.   if (!is_symbol(id))
  555.     CallError(stacktop,"dynamic-set: non-symbolic reference",id,NONCONTINUABLE);
  556.  
  557.   if (!is_cons(forms)) 
  558.     CallError(stacktop,"dynamic-set: missing value form",forms,NONCONTINUABLE);
  559.  
  560.   form = CAR(forms); forms = CDR(forms);
  561.  
  562.   if (forms != nil)
  563.     CallError(stacktop,"dynamic-set: extraneous forms",forms,NONCONTINUABLE);
  564.  
  565.   STACK_TMP(id);
  566.   form = EUCALL_3(module_eval,mod,env,form);
  567.   UNSTACK_TMP(id);
  568.   walker = DYNAMIC_ENV();
  569.  
  570.   while (walker != NULL) {
  571.     if (walker->variable == id) return((walker->value = form));
  572.     walker = walker->next;
  573.   }
  574.  
  575.   if (id->SYMBOL.gvalue == NULL) {
  576.     fprintf(stderr,"****Illegal assignment to undeclared variable: ");
  577.     EUCALL_2(Fn_print,id,StdErr);
  578.     fprintf(stderr,"****Implicit defvar used\n");
  579.   }
  580.  
  581.   return((id->SYMBOL.gvalue = form));
  582. }
  583. EUFUN_CLOSE
  584.  
  585. LispObject special_dynamic_let;
  586. EUFUN_3( Sf_dynamic_let, mod, env, forms)
  587. {
  588.   LispObject bindings;
  589.   Env save;
  590.  
  591.   if (!is_cons(forms))
  592.     CallError(stacktop,"dynamic-let: null forms",forms,NONCONTINUABLE);
  593.  
  594.   bindings = CAR(forms); forms = CDR(forms);
  595.  
  596.   if (!is_cons(bindings)) 
  597.     CallError(stacktop,
  598.           "dynamic-let: invalid binding forms",bindings,NONCONTINUABLE);
  599.  
  600.   save = DYNAMIC_ENV(); /* Hang on for exit... */
  601.   
  602.   STACK_TMP(forms); 
  603.   STACK_TMP(save);
  604.   while (is_cons(bindings)) {
  605.     LispObject id,val,bind;
  606.     LispObject xx;
  607.  
  608.     bind = CAR(bindings);
  609.     STACK_TMP(CDR(bindings));
  610.     if (!is_cons(bind))
  611.       CallError(stacktop,
  612.         "dynamic-let: weird binding",bindings,NONCONTINUABLE);
  613.  
  614.     id = CAR(bind); bind = CDR(bind);
  615.  
  616.     if (!is_symbol(id)) 
  617.       CallError(stacktop,"dynamic-let: non-symbolic var",id,NONCONTINUABLE);
  618.  
  619.     if (!is_cons(bind))
  620.       CallError(stacktop,"dynamic-let: weird binding",bindings,NONCONTINUABLE);
  621.  
  622.     val = CAR(bind);
  623.  
  624.     STACK_TMP(id);
  625.     val = EUCALL_3(module_eval,ARG_0(stackbase),ARG_1(stackbase),val);
  626.     UNSTACK_TMP(id);
  627.  
  628.     xx = &(allocate_env(stacktop,id,val,
  629.             (LispObject)DYNAMIC_ENV())->ENV);    
  630.     DYNAMIC_ENV()=xx;
  631.     UNSTACK_TMP(bindings);
  632.   }
  633.   UNSTACK_TMP(save);
  634.   UNSTACK_TMP(forms);
  635.   /* Do body... */
  636.  
  637.   forms = EUCALL_3(Sf_progn,ARG_0(stackbase),ARG_1(stackbase),forms);
  638.  
  639.   DYNAMIC_ENV() = save; /* Repoint */
  640.  
  641.   return(forms);
  642. }
  643. EUFUN_CLOSE    
  644.  
  645. EUFUN_1( Fn_dynamic, form)
  646. {
  647.   {
  648.     Env ee = DYNAMIC_ENV();
  649.     while (ee!=NULL) {
  650.       if (ee->variable == form) return ee->value;
  651.       ee = ee->next;
  652.     }
  653.   }
  654.   {
  655.     LispObject ans;
  656.     ans =  (form->SYMBOL).gvalue;
  657.     if (ans==NULL) {        /* signal UNBOUND_DYNAMIC_VARIABLE */
  658.       ans = CallError(stacktop,"Unset dynamic variable ",form,CONTINUABLE);
  659.       (form->SYMBOL).gvalue = ans;
  660.     }
  661.     return ans;
  662.   }
  663. }
  664. EUFUN_CLOSE
  665.  
  666. LispObject special_dynamic;
  667. EUFUN_3( Sf_dynamic, mod, env, form)
  668. {
  669.   IGNORE(mod); IGNORE(env);
  670.  
  671.   while (!is_symbol(CAR(form)) || CDR(form)!=nil)
  672.     form = CallError(stacktop,"dynamic: Illegal dynamic form ",form,CONTINUABLE);
  673.  
  674.   form = CAR(form);
  675.  
  676.   {
  677.     Env ee = DYNAMIC_ENV();
  678.     while (ee!=NULL) {
  679.       if (ee->variable == form) return ee->value;
  680.       ee = ee->next;
  681.     }
  682.   }
  683.   {
  684.     LispObject ans;
  685.     ans =  (form->SYMBOL).gvalue;
  686.     if (ans==NULL) {        /* signal UNBOUND_DYNAMIC_VARIABLE */
  687.       ans = CallError(stacktop,"dynamic: unset dynamic variable ",form,CONTINUABLE);
  688.       (form->SYMBOL).gvalue = ans;
  689.     }
  690.     return ans;
  691.   }
  692. }
  693. EUFUN_CLOSE
  694.  
  695. LispObject special_quote;
  696. EUFUN_3( Sf_quote, mod, env, forms)
  697. {
  698.   IGNORE(mod); IGNORE(env);
  699.  
  700.   if (!is_cons(forms))
  701.     CallError(stacktop,"quote: bad forms",forms,NONCONTINUABLE);
  702.  
  703.   return(CAR(forms));
  704. }
  705. EUFUN_CLOSE
  706.  
  707. /*
  708.  
  709.  * Handlers...
  710.  
  711.  */
  712.  
  713. LispObject special_with_handler;
  714. EUFUN_3( Sf_with_handler, mod, env, forms)
  715. {
  716.   LispObject handler;
  717.   LispObject retval;
  718.   
  719.   if (!is_cons(forms))
  720.     CallError(stacktop,
  721.           "with-handler: missing handler function",forms,NONCONTINUABLE);
  722.  
  723.   handler = CAR(forms);
  724.  
  725.   handler = EUCALL_3(module_eval,mod,env,handler);
  726.   
  727.   if (!is_function(handler))
  728.     CallError(stacktop,
  729.           "with-handler: non-functional handler",handler,NONCONTINUABLE);
  730.  
  731.   /* So far, so good - bung this onto the handler stack... */
  732.  
  733.   HANDLER_STACK() = EUCALL_2(Fn_cons,handler,HANDLER_STACK());
  734.  
  735.   /* Process the forms... */
  736.  
  737.   retval = EUCALL_3(Sf_progn,ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,CDR(ARG_2(stackbase)));
  738.  
  739.   /* Unhitch the handler... */
  740.  
  741.   HANDLER_STACK() = CDR(HANDLER_STACK());
  742.  
  743.   return(retval);
  744. }
  745. EUFUN_CLOSE
  746.  
  747. /*******    
  748.  * modified handler interactions
  749.  *
  750.  *******/
  751.  
  752. EUFUN_1(Fn_push_handler,handler)
  753. {
  754.   HANDLER_STACK() = EUCALL_2(Fn_cons,handler,HANDLER_STACK());
  755.   
  756.   return (HANDLER_STACK());
  757. }
  758. EUFUN_CLOSE
  759.  
  760. EUFUN_0(Fn_pop_handler)
  761. {
  762.   HANDLER_STACK() = CDR(HANDLER_STACK());
  763.   
  764.   return HANDLER_STACK();
  765. }
  766. EUFUN_CLOSE
  767.  
  768. /* I'll never write a complicated one (in C) */
  769. EUFUN_1(Fn_simple_call_cc,fn)
  770. {
  771.   LispObject cont;
  772.   LispObject args;
  773.   cont=allocate_continue(stacktop);
  774.   
  775.   STACK_TMP(cont);
  776.  
  777.   if (set_continue(stacktop,cont))
  778.     {    /* forcible return */
  779.       UNSTACK_TMP(cont);
  780.       return(cont->CONTINUE.value);
  781.     }
  782.  
  783.   UNSTACK_TMP(cont);
  784.   STACK_TMP(cont);
  785.   args=EUCALL_2(Fn_cons,cont,nil);
  786.   
  787.   return(EUCALL_2(module_mv_apply_1,ARG_0(stackbase)/*fn*/,args));
  788.  
  789. }
  790. EUFUN_CLOSE
  791.  
  792. /* Hack... */
  793.  
  794. LispObject special_evalcm;
  795. EUFUN_3(Sf_evalcm, mod, env, form)
  796. {
  797.   LispObject ans;
  798.  
  799.   if (!is_cons(form))
  800.     CallError(stacktop,"eval/cm: no arguments",form,NONCONTINUABLE);
  801.  
  802.   if (is_cons(CDR(form)))
  803.     CallError(stacktop,"eval/cm: too many arguments",form,NONCONTINUABLE);
  804.  
  805.   form = EUCALL_3(module_eval,mod,env,form);
  806.  
  807.   ans = EUCALL_2(process_top_level_form,mod,CAR(form));
  808.  
  809.   return(ans);
  810. }
  811. EUFUN_CLOSE
  812.  
  813. /* Tag Body... */
  814.  
  815. /*
  816.  
  817.  * 'tagbody'
  818.  *
  819.  *   Plan: Do a naive walk on the body to extract a table of symbols with
  820.  *         following code, rig a continuation for 'go' statements to jump
  821.  *         to and run them in sequence until done...
  822.  
  823.  */
  824.  
  825. /* ******************** This function cannot be called *************** */
  826. static LispObject tagbody_before_label(LispObject *stacktop,LispObject body)
  827. {
  828.   if (!is_cons(body)) return(nil);
  829.   if (is_symbol(CAR(body))) return(nil);
  830.  
  831.   return(EUCALL_2(Fn_cons,CAR(body),tagbody_before_label(stacktop,CDR(body))));
  832. }
  833.  
  834. static LispObject tagbody_suck_symbols(LispObject *stacktop,LispObject body)
  835. {
  836.   if (!is_cons(body)) return(nil);
  837.   if (is_symbol(CAR(body))) return(tagbody_suck_symbols(stacktop,CDR(body)));
  838.  
  839.   return(EUCALL_2(Fn_cons,CAR(body),tagbody_suck_symbols(stacktop,CDR(body))));
  840. }
  841.  
  842. static LispObject tagbody_handle;
  843.  
  844. LispObject special_tagbody;
  845. EUFUN_3( Sf_tagbody, mod, env, forms)
  846. {
  847.   LispObject table,cont;
  848.   LispObject walker;
  849.   LispObject before;
  850.   LispObject res;
  851.  
  852.   table = (LispObject) allocate_table(stacktop,Fn_eq);
  853.   STACK_TMP(table);
  854.   before = nil;
  855.   before = tagbody_suck_symbols(stacktop,forms);
  856.   STACK_TMP(before);
  857.  
  858.   walker = forms;
  859.   while (is_cons(walker)) {
  860.     if (is_symbol(CAR(walker))) break;
  861.     walker = CDR(walker);
  862.   }
  863.  
  864.   if (is_cons(walker)) {
  865.     Env augenv;
  866.     LispObject runbody;
  867.  
  868.     /* Non-trivial label forms... */
  869.  
  870.     cont = allocate_continue(stacktop);
  871.     STACK_TMP(cont);
  872.  
  873.     do {
  874.       LispObject label, body;
  875.  
  876.       label = CAR(walker); walker = CDR(walker);
  877.       body = tagbody_suck_symbols(stacktop,walker);
  878.       EUCALL_3(tref_updator,table,label,body);
  879.  
  880.       while (is_cons(walker)) {
  881.     if (is_symbol(CAR(walker))) break;
  882.     walker = CDR(walker);
  883.       }
  884.     } while (is_cons(walker));
  885.  
  886.     /* Construct the augmented environment... */
  887.  
  888.     UNSTACK_TMP(cont);
  889.     augenv = (Env)allocate_env(stacktop,tagbody_handle,cont,env);
  890.     STACK_TMPV(augenv);
  891.  
  892.     runbody = before;
  893.  
  894.    reset:
  895.  
  896.     /* Go continuation... */
  897.  
  898.     if (set_continue(stacktop,cont)) {
  899.  
  900.       /* Go has been called... */
  901.  
  902.       runbody = EUCALL_2(Fn_tref,table,cont->CONTINUE.value);
  903.  
  904.       if (runbody == nil)
  905.     CallError(stacktop,
  906.           "go: no such label",cont->CONTINUE.value,NONCONTINUABLE);
  907.  
  908.       goto reset;
  909.     }
  910.  
  911.     UNSTACK_TMPV(augenv);
  912.     
  913.     STACK_TMP(cont);
  914.     res = EUCALL_3(Sf_progn,mod,(LispObject)augenv,runbody);
  915.     UNSTACK_TMP(cont);
  916.     unset_continue(cont);
  917.  
  918.     return(res);
  919.   }
  920.  
  921.   res = EUCALL_3(Sf_progn,mod,env,before);
  922.  
  923.   return(res);
  924. }
  925. EUFUN_CLOSE
  926.  
  927. LispObject special_go;
  928. EUFUN_3( Sf_go, mod, env, forms)
  929. {
  930.   LispObject tag;
  931.   Env walker;
  932.  
  933.   IGNORE(mod);
  934.  
  935.   if (!is_cons(forms))
  936.     CallError(stacktop,"go: no tag",forms,NONCONTINUABLE);
  937.  
  938.   tag = CAR(forms);
  939.  
  940.   if (!is_symbol(tag))
  941.     CallError(stacktop,"go: non-symbolic tag",tag,NONCONTINUABLE);
  942.  
  943.   walker = (Env)env;
  944.   while (walker != NULL) {
  945.     if (walker->variable == tagbody_handle)
  946.       call_continue(stacktop,walker->value,tag);
  947.     walker = walker->next;
  948.   }
  949.  
  950.   CallError(stacktop,"go: not within tagbody",nil,NONCONTINUABLE);
  951.  
  952.   return(nil);
  953. }
  954. EUFUN_CLOSE
  955.  
  956. void initialise_specials(LispObject *stacktop)
  957. {
  958.   special_table = (LispObject) allocate_table(stacktop,Fn_eq);
  959.   add_root(&special_table);
  960.   
  961.   special_lambda = my_make_special(stacktop,"lambda",Sf_lambda);
  962.   add_root(&special_lambda);
  963.   special_macro_lambda = my_make_special(stacktop,"macro-lambda",Sf_mlambda);
  964.   add_root(&special_macro_lambda);
  965.   special_setq   = my_make_special(stacktop,"setq",Sf_setq);
  966.   add_root(&special_setq);
  967.   special_progn  = my_make_special(stacktop,"progn",Sf_progn);
  968.   add_root(&special_progn);
  969.   special_if     = my_make_special(stacktop,"if",Sf_if);
  970.   add_root(&special_if);
  971.   
  972.   special_letcc  = my_make_special(stacktop,"let/cc",Sf_letcc);
  973.   add_root(&special_letcc);
  974.   special_unwind_protect = my_make_special(stacktop,"unwind-protect",Sf_unwind_protect);
  975.   add_root(&special_unwind_protect);
  976.   
  977. /*  last_continue = nil;*/
  978.  
  979.   special_dynamic_setq = my_make_special(stacktop,"dynamic-setq",Sf_dynamic_setq);
  980.   add_root(&special_dynamic_setq);
  981.   special_dynamic_set  = my_make_special(stacktop,"dynamic-set",Sf_dynamic_set);
  982.   add_root(&special_dynamic_set);
  983.   special_dynamic_let  = my_make_special(stacktop,"dynamic-let",Sf_dynamic_let);
  984.   add_root(&special_dynamic_let);
  985.   special_dynamic      = my_make_special(stacktop,"dynamic",Sf_dynamic);
  986.   add_root(&special_dynamic_let);
  987.   
  988.   special_quote = my_make_special(stacktop,"quote",Sf_quote);
  989.   add_root(&special_quote);
  990.   
  991.   special_with_handler = my_make_special(stacktop,"with-handler",Sf_with_handler);
  992.   add_root(&special_with_handler);
  993.   
  994.   special_tagbody = my_make_special(stacktop,"tagbody",Sf_tagbody);
  995.   add_root(&special_tagbody);
  996.   tagbody_handle = get_symbol(stacktop,"***tagbody-handle***");
  997.   add_root(&tagbody_handle);
  998.   special_go = my_make_special(stacktop,"go",Sf_go);
  999.   add_root(&special_go);
  1000. }
  1001.  
  1002.